\ this is a mess

Requires Heap
Requires SORA\Framework
Requires Sprig

\ From: http://www.blackpawn.com/texts/lightmaps/default.html

Component: texture-packing

0 value <<?
8 constant /sdl-rect

: <<
   1 +to <<?  postpone << ; immediate

: exit
   <<? if postpone >> then postpone exit  ; immediate

: ?exit
   <<? if postpone >> then postpone ?exit ; immediate

: >>
   -1 +to <<?   postpone >> ; immediate

: Withable:   Block-type:  ;

:macro this   blk @ ;

: sizeof   ' >body @ ;

: field   blk property ;

also sdl-surfaces
: @sdl-width   ->w @ ;
: @sdl-height  ->h @ ;
previous


Withable: [Node]
   cell field child1
   cell field child2
   /sdl-rect field rect
   cell field s

sizeof [node] constant node

: leaf?
   child1 @ child2 @ or ;

: instance
   chunk ;

: dispose ( node -- )
   ?dup 0= ?exit
   dup recycle << child1 @ recurse child2 @ recurse >> ;

: fits?
   locals| rect surface |
   surface @sdl-width  rect @width  <
   surface @sdl-height  rect @height  < and ;

: snug?
   locals| rect surface |
   surface @sdl-width  rect @width  =
   surface @sdl-height  rect @height  = and ;


: insert ( surface node -- node )
   << locals| surface |
   leaf? not if
      child1 @ recurse ?dup ?exit
      child2 @ recurse exit
   else
      s @ if 0 exit then
      surface rect fits? not if 0 exit then
      surface rect snug? if this exit then
      node instance child1 !
      node instance child2 !
      rect @width surface @sdl-width -
      rect @height surface @sdl-height - > if
         rect @left   rect @top   surface @sdl-width   rect @height
            child1 @ << rect >> rect!
         rect @left surface @sdl-width +   rect @top   rect @width   rect @height
            child2 @ << rect >> rect!
      else
         rect @left   rect @top   rect @width   surface @sdl-height
            child1 @ << rect >> rect!
         rect @left   rect @top surface @sdl-height +   rect @width   rect @height
            child2 @ << rect >> rect!
      then
      surface child1 @ recurse
   then >> ;

close texture-packing


using texture-packing

0 value y-extent
-? 0 value xt
:noname  2drop 2drop ; to xt

: blit-tree  ( node surface -- )
   locals| surface |
   << s @ surface rect @left rect @top SPG_DrawBlit
   rect @top s @ @sdl-height +   y-extent  max to y-extent
      rect @rect xt execute
   child1 @ ?dup if surface recurse then
   child2 @ ?dup if surface recurse then >> ;

: pack   ( surface-list count -- surface )
   256 2048 sdl-new locals| surface |
   node instance <<
      0 to y-extent
      0 do @+ this insert loop drop
      this surface blit-tree
      surface 256 y-extent sdl-resize
   this dispose >> ;

:[] pack:[  ( surface-list count -- surface )  ( x y w h -- )
   to xt pack ;

close texture-packing
